home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / tttsrc51.zip / MISCTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1993-01-04  |  21KB  |  790 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.10                              }
  5. {                                                                          }
  6. {                                                                          }
  7. {               Copyright 1986-1993 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  MiscTTT5          }
  14.                      {--------------------------------}
  15.  
  16. {Change history:  }
  17.  
  18.  
  19. {$S-,R-,V-}       
  20. {$IFNDEF DEBUG}
  21. {$D-}
  22. {$ENDIF}
  23.  
  24. Unit MiscTTT5;
  25. {Change History : April 1, 1989    Modified Printer Status and added global
  26.                                    LPTport 
  27.                            5.01a   Removed references to VER50 and added
  28.                                    DEBUG compiler directive                                
  29.                   3/24/91  5.02a   Check for single digits in dates
  30.                   7/23/91  5.02b   Corrected Date formatting
  31.                   11/4/91  5.02c   Corrected File_Size & Time
  32.                  01/04/93  5.10    DPMI compatible version
  33. }
  34. Interface
  35.  
  36. Uses CRT, DOS, FastTTT5, Strnttt5;
  37.  
  38. TYPE
  39.    Dates = word;   {change to longint for greater date ranges}
  40.  
  41. CONST
  42.    MMDDYY   = 1;   {Date formats}
  43.    MMDDYYYY = 2;
  44.    MMYY     = 3;
  45.    MMYYYY   = 4;
  46.    DDMMYY   = 5;
  47.    DDMMYYYY = 6;
  48.  
  49. VAR
  50.    LPTport,     {0=lpt1, 1=lpt2, 2=lpt3}
  51.    ClockX,
  52.    ClockY,
  53.    ClockF,
  54.    ClockB : byte;
  55.  
  56. Function  Exist(Filename:string):boolean;
  57. Function  CopyFile(SourceFile, TargetFile:string): byte;
  58. Function  File_Size(Filename:string): longint;
  59. {$IFNDEF VER40}
  60. Function  File_Drive(Full:string): string;
  61. Function  File_Directory(Full:string): string;
  62. Function  File_Name(Full:string): string;
  63. Function  File_Ext(Full:string): String;
  64. {$ENDIF}
  65. Function  Time: string;
  66. Procedure Clock;
  67. Function  Date: String;
  68. Procedure PrintScreen;
  69. Procedure Beep;
  70. function  Printer_Status:byte;
  71. Function  Alternate_Printer_Status:byte;
  72. Function  Printer_ready:boolean;
  73. Procedure FlushKeyBuffer;
  74. Procedure Reset_Printer;
  75. Function  DMY_to_String(D,M,Y:word;format:byte): string;
  76. Function  Date_To_Julian(InDate:string;format:byte): dates;
  77. Function  Julian_to_Date(J:dates;format:byte):string;
  78. Function  Today_in_Julian: dates;
  79. Function  Date_Within_Range(Min,Max,Test:dates):boolean;
  80. Function  Valid_Date(Indate:string;format:byte): boolean;
  81. Function  Future_Date(InDate:string;format:byte;Days:word): string;
  82. Function  Unformatted_date(InDate:string): string;
  83.  
  84. Implementation
  85.  
  86. Const
  87.     LastYearNextCentuary = 78;
  88.  
  89. Function Exist(Filename:string):boolean;
  90. {returns true if file exists}
  91. var Inf: SearchRec;
  92. begin
  93.     FindFirst(Filename,AnyFile,Inf);
  94.     Exist := (DOSError = 0);
  95. end;  {Func Exist}
  96.  
  97. Function CopyFile(SourceFile, TargetFile:string): byte;
  98. {return codes:  0 successful
  99.                 1 source and target the same
  100.                 2 cannot open source
  101.                 3 unable to create target
  102.                 4 error during copy
  103. }
  104. var
  105.   Source,
  106.   Target : file;
  107.   BRead,
  108.   Bwrite : word;
  109.   FileBuf  : array[1..2048] of char;
  110. begin
  111.     If SourceFile = TargetFile then
  112.     begin
  113.         CopyFile := 1;
  114.         exit;
  115.     end;
  116.     Assign(Source,SourceFile);
  117.     {$I-}
  118.     Reset(Source,1);
  119.     {$I+}
  120.     If IOResult <> 0 then
  121.     begin
  122.         CopyFile := 2;
  123.         exit;
  124.     end;
  125.     Assign(Target,TargetFile);
  126.     {$I-}
  127.     Rewrite(Target,1);
  128.     {$I+}
  129.     If IOResult <> 0 then
  130.     begin
  131.         CopyFile := 3;
  132.         exit;
  133.     end;
  134.     Repeat
  135.          BlockRead(Source,FileBuf,SizeOf(FileBuf),BRead);
  136.          BlockWrite(Target,FileBuf,Bread,Bwrite);
  137.     Until (Bread = 0) or (Bread <> BWrite);
  138.     Close(Source);
  139.     Close(Target);
  140.     If Bread <> Bwrite then
  141.        CopyFile := 4
  142.     else
  143.        CopyFile := 0;
  144. end; {of func CopyFile}
  145.  
  146.  Function File_Size(Filename:string): longint;
  147.  {returns  -1   if file not found}
  148.  var
  149.     F : file of byte;
  150.  begin
  151.      if not Exist(Filename) then    {5.02c}
  152.         File_Size := -1
  153.      else
  154.      begin
  155.         Assign(F,Filename);
  156.         {$I-}
  157.         Reset(F);
  158.         {$I+}
  159.         If IOResult <> 0 then {ignore};
  160.         {$I-}
  161.         File_Size := FileSize(F);
  162.         {$I+}
  163.         If IOResult <> 0 then 
  164.            File_Size := -1;
  165.         Close(F);
  166.      end;
  167.  end; {of func File_Size}
  168.  
  169. {$IFNDEF VER40}
  170.  Function File_Split(Part:byte;Full:string): string;
  171.  {used internally}
  172.  var
  173.     D : DirStr;
  174.     N : NameStr;
  175.     E : ExtStr;
  176.  begin
  177.      FSplit(Full,D,N,E);
  178.      Case Part of
  179.      1 : File_Split := D;
  180.      2 : File_Split := N;
  181.      3 : File_Split := E;
  182.      end;
  183.  end; {of func File_Split}
  184.  
  185.  Function File_Drive(Full:string): string;
  186.  {}
  187.  var
  188.    Temp : string;
  189.    P : byte;
  190.  begin
  191.      Temp := File_Split(1,Full);
  192.      P := Pos(':',Temp);
  193.      If P <> 2 then
  194.         File_Drive := ''
  195.      else
  196.         File_Drive := upcase(Temp[1]);
  197.  end; {of func File_Drive}
  198.  
  199.  Function File_Directory(Full:string): string;
  200.  {}
  201.  var
  202.    Temp : string;
  203.    P : byte;
  204.  begin
  205.      Temp := File_Split(1,Full);
  206.      P := Pos(':',Temp);
  207.      If P = 2 then
  208.         Delete(Temp,1,2);                 {remove drive}
  209.      If (Temp[length(Temp)]  ='\') and (temp <> '\') then
  210.         Delete(temp,length(Temp),1);      {remove last backslash}
  211.      File_Directory := Temp;
  212.  end; {of func File_Directory}
  213.  
  214.  Function File_Name(Full:string): string;
  215.  {}
  216.  begin
  217.      File_Name := File_Split(2,Full);
  218.  end; {of func File_Name}
  219.  
  220.  Function File_Ext(Full:string): String;
  221.  {}
  222.  var
  223.    Temp : string;
  224.  begin
  225.      Temp := File_Split(3,Full);
  226.      If (Temp = '') or (Temp = '.') then
  227.         File_Ext := temp
  228.      else
  229.         File_Ext := copy(Temp,2,3);
  230.  end; {of func File_Ext}
  231. {$ENDIF}
  232.  
  233. function time: string;
  234. var
  235.   hour,min,sec:     string[2];
  236.   H,M,S,T : word;
  237. begin
  238.     GetTime(H,M,S,T);
  239.     Str(H,Hour);
  240.     Str(M,Min);
  241.     Str(S,Sec);
  242.     if S < 10 then            {pad a leading zero if sec is < 10 }
  243.       sec := '0'+sec;
  244.     if M < 10 then            {pad a leading zero if min is < 10 }
  245.         min := '0'+min;
  246.     if H > 12 then           { assign an a.m. or p.m. string }
  247.     begin
  248.        str(H - 12,hour);
  249.        IF length(hour) = 1 then 
  250.           Hour := ' '+hour;
  251.        time := hour+':'+min+':'+sec+' p.m.'
  252.     end
  253.     else if H = 0 then   {5.02c}
  254.        time := '24:'+min+':'+sec+' a.m.'
  255.     else
  256.        time := hour+':'+min+':'+sec+' a.m.';
  257.     if H = 12 then
  258.        time := hour+':'+min+':'+sec+' p.m.';
  259. end;
  260.  
  261. {$F+}
  262. Procedure Clock;
  263. {}
  264. begin
  265.     Fastwrite(ClockX,ClockY,attr(ClockF,ClockB),Time);
  266. end; {of proc Clock}
  267. {$F-}
  268.  
  269. function Date: String;
  270. type
  271.   WeekDays = array[0..6]  of string[9];
  272.   Months   = array[1..12] of string[9];
  273. const
  274.     DayNames   : WeekDays  = ('Sunday','Monday','Tuesday','Wednesday',
  275.                               'Thursday','Friday','Saturday');
  276.     MonthNames : Months    = ('January','February','March','April','May',
  277.                               'June','July','August','September',
  278.                               'October','November','December');
  279. var
  280.  Y,
  281.  M,
  282.  D,
  283.  DayOfWeek : word;
  284.  Year   : string;
  285.  Day    : string;
  286. begin
  287.     GetDate(Y,M,D,DayofWeek);
  288.     Str(Y,Year);
  289.     Str(D,Day);
  290.     Date := DayNames[DayOfWeek]+' '+MonthNames[M]+' '+Day+', '+Year;
  291. end;
  292.  
  293. Procedure PrintScreen;
  294. var Regpack : registers;
  295. begin
  296.     intr($05,regpack);
  297. end;
  298.  
  299. procedure Beep;
  300. begin
  301.     sound(800);Delay(150);
  302.     sound(600);Delay(100);
  303.     Nosound;
  304. end;
  305.  
  306. Function Printer_Status:byte;
  307. {Credits: Robert W. Lewis, VA thanks! Special masking employed for non-
  308.           standard printers, e.g. daisy wheels!!! }
  309. var Recpack : registers;
  310. begin
  311.     with recpack do
  312.     begin
  313.         Ah := 2;
  314.         Dx := LPTport;
  315.         intr($17,recpack);
  316.         If (Ah and $B8) = $90 then
  317.            Printer_Status := 0           {all's well}
  318.         else
  319.            If (Ah and $20) = $20 then
  320.               Printer_Status := 1        {no Paper}
  321.         else
  322.            If (Ah and $10) = $00 then
  323.               Printer_Status := 2        {off line}
  324.         else
  325.            If (Ah and $80) = $00 then
  326.               Printer_Status := 3        {busy}
  327.         else
  328.            If (Ah and $08) = $08 then
  329.               Printer_Status := 4;       {undetermined error}
  330.     end;
  331. end;
  332.  
  333. Function Alternate_Printer_Status:byte;
  334. var Recpack : registers;
  335. begin
  336.     with recpack do
  337.     begin
  338.         Ah := 2;
  339.         Dx := LPTport;
  340.         intr($17,recpack);
  341.         If (Ah and $20) = $20 then
  342.               Alternate_Printer_Status := 1        {no Paper}
  343.         else
  344.            If (Ah and $10) = $00 then
  345.               Alternate_Printer_Status := 2        {off line}
  346.         else
  347.            If (Ah and $80) = $00 then
  348.               Alternate_Printer_Status := 3        {busy}
  349.         else
  350.            If (Ah and $08) = $08 then
  351.               Alternate_Printer_Status := 4        {undetermined error}
  352.         else
  353.             Alternate_Printer_Status := 0           {all's well}
  354.     end;
  355. end;
  356.  
  357.  
  358. function printer_ready :boolean;
  359. begin
  360.     Printer_ready := (Printer_Status = 0);
  361. end;
  362.  
  363. Procedure FlushKeyBuffer;
  364. var Recpack : registers;
  365. begin
  366.     with recpack do
  367.     begin
  368.         Ax := ($0c shl 8) or 6;
  369.         Dx := $00ff;
  370.     end;
  371.     Intr($21,recpack);
  372. end;
  373.  
  374. procedure Reset_Printer; {1.1}
  375. var
  376.   address: ^integer;
  377.   portno,delay : integer;
  378. begin
  379. {$IFDEF DPMI}
  380.    address := ptr(seg0040,$0008);
  381. {$ELSE}
  382.    address := ptr($0040,$0008);
  383. {$ENDIF}
  384.    portno := address^ + 2;
  385.    port[portno] := 232;
  386.    for delay := 1 to 2000 do {nothing};
  387.    port[portno] := 236;
  388. end; {ResetPrinter}
  389.  
  390. {++++++++++++++++++++++++++++++++++}
  391. {                                  }
  392. {    D A T E    R O U T I N E S    }
  393. {                                  }
  394. {++++++++++++++++++++++++++++++++++}
  395.  
  396. (*
  397.  Note that the Julian date logic applied in these routines is that day 1 is
  398.  January 1, 1900. All subsequent dates are represented by the number of
  399.  days elapsed since day 1. The INTERFACE section includes a declaration of
  400.  type DATES - this is set equal to type word, but it could be changed to
  401.  type longint to provide a much greater date range. 
  402.  
  403.  Throughout these procedures and functions a date "format" must be passed. The
  404.  format codes are:
  405.  
  406.                   1  MM/DD/YY
  407.                   2  MM/DD/YYYY
  408.                   3  MM/YY
  409.                   4  MM/YYYY
  410.                   5  DD/MM/YY {International format}
  411.                   6  DD/MM/YYYY   {   "    }
  412.  
  413.  When passing dates in string form the "separators" are not significant. For
  414.  example, the following strings are all treated alike:
  415.  
  416.                      120188
  417.                      12/01/88
  418.                      12-01-88
  419.                      12-01/88
  420.                      12----01----88
  421.  Only the numerical digits are significant, the alphas are ignored.
  422.  
  423. *)
  424.   function JustNumbers(DStr:string): boolean;       {5.02b}
  425.   {}
  426.   var P:byte;
  427.   begin
  428.      P := 0;
  429.      repeat
  430.        inc(P);
  431.      until (not (DStr[P] in ['0'..'9'])) or (P > length(DStr));
  432.      JustNumbers := (P > length(DStr));
  433.   end; {JustNumbers}
  434.  
  435.   function PadDateStr(DStr:string;Format:byte):string;
  436.   {}
  437.   const
  438.     Sep:string[1] = '\';
  439.   var
  440.     Part1,Part2,Part3: string[8];
  441.     P: byte;
  442.  
  443.             procedure PadOut(var S:string; width:byte);
  444.             begin
  445.                S := padright(S,width,'0');
  446.             end;
  447.  
  448.   begin
  449.      P := 0;
  450.      repeat
  451.        inc(P);
  452.      until (not (DStr[P] in ['0'..'9'])) or (P > length(DStr));
  453.      Part1 := copy (DStr,1,pred(P));
  454.      delete(DStr,1,P);
  455.      P:= 0;
  456.      repeat
  457.         inc(P);
  458.      until (not (DStr[P] in ['0'..'9'])) or (P > length(DStr));
  459.      Part2 := copy(DStr,1,pred(P));
  460.      Part3 := copy(DStr,succ(P),4);
  461.      case Format of
  462.       MMDDYY,DDMMYY:begin
  463.           PadOut(Part1,2);
  464.           PadOut(Part2,2);
  465.           PadOut(Part3,2);
  466.           DStr := Part1+Sep+Part2+Sep+Part3;
  467.       end;
  468.       MMDDYYYY,DDMMYYYY:begin
  469.           PadOut(Part1,2);
  470.           PadOut(Part2,2);
  471.           PadOut(Part3,4);
  472.           DStr := Part1+Sep+Part2+Sep+Part3;
  473.       end;
  474.       MMYY:begin
  475.           PadOut(Part1,2);
  476.           PadOut(Part2,2);
  477.           DStr := Part1+Sep+Part2;
  478.       end;
  479.       MMYYYY:begin
  480.           PadOut(Part1,2);
  481.           PadOut(Part2,4);
  482.           DStr := Part1+Sep+Part2;
  483.       end;
  484.      end; {case}
  485.      PadDateStr := DStr;
  486.   end; {PadDateStr}
  487.  
  488.   Function Nth_Number(InStr:string;Nth:byte) : char;
  489.   {Returns the nth number in an alphanumeric string}
  490.   var
  491.      Counter : byte;
  492.      B, Len : byte;
  493.   begin
  494.       Counter := 0;
  495.       B := 0;
  496.       Len := Length(InStr);
  497.       Repeat
  498.            Inc(B);
  499.            If InStr[B] in ['0'..'9'] then
  500.               Inc(Counter);
  501.       Until (Counter = Nth) or (B >= Len);
  502.       If (Counter >= Len) and ( (InStr[Len] in ['0'..'9']) = false) then
  503.          Nth_Number := #0
  504.       else
  505.          Nth_Number := InStr[B];
  506.   end; {of func Nth_Number}
  507.  
  508.  Function Day(DStr:string;Format:byte): word;
  509.  {INTERNAL}
  510.  var
  511.     DayStr: string;
  512.  begin
  513.      if not JustNumbers(DStr) then                       {5.02b}
  514.         DStr := PadDateStr(DStr,Format);
  515.      Case Format of
  516.      MMDDYY,
  517.      MMDDYYYY :  DayStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  518.      DDMMYY,
  519.      DDMMYYYY :  DayStr := Nth_Number(DStr,1)+Nth_Number(DStr,2);
  520.      else     DayStr := '01';
  521.      end;
  522.      Day := Str_To_Int(DayStr);
  523.  end; {of func Day}
  524.  
  525.  Function Month(DStr:string;Format:byte): word;
  526.  {INTERNAL}
  527.  var
  528.     MonStr: string;
  529.  begin
  530.      if not JustNumbers(DStr) then                      {5.02b}
  531.         DStr := PadDateStr(DStr,Format);
  532.      Case Format of
  533.      MMDDYY,
  534.      MMDDYYYY,
  535.      MMYY,
  536.      MMYYYY    :  MonStr := Nth_Number(DStr,1)+Nth_Number(DStr,2);
  537.      DDMMYY,
  538.      DDMMYYYY  :  MonStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  539.      end;
  540.      Month := Str_To_Int(MonStr);
  541.  end; {of func Month}
  542.  
  543.  Function Year(DStr:string;Format:byte): word;
  544.  {INTERNAL}
  545.  var
  546.     YrStr   : string;
  547.     TmpYr   : word;
  548.  begin
  549.      if not JustNumbers(DStr) then                     {5.02b}
  550.         DStr := PadDateStr(DStr,Format);
  551.      Case Format of
  552.      MMDDYY,
  553.      DDMMYY   :  YrStr := Nth_Number(DStr,5)+Nth_Number(DStr,6);
  554.      MMDDYYYY,
  555.      DDMMYYYY :  YrStr := Nth_Number(DStr,5)+Nth_Number(DStr,6)+
  556.                      Nth_Number(DStr,7)+Nth_Number(DStr,8);
  557.      MMYY     :  YrStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  558.      MMYYYY   :  YrStr := Nth_Number(DStr,3)+Nth_Number(DStr,4)+
  559.                      Nth_Number(DStr,5)+Nth_Number(DStr,6);
  560.      end;
  561.      TmpYr := Str_To_Int(YrStr);
  562.      If TmpYr < LastYearNextCentuary then
  563.         TmpYr := 2000 + TmpYr
  564.      else
  565.         If Tmpyr < 1000 then
  566.            TmpYr := 1900 + TmpYr;
  567.      Year := TmpYr;
  568.  end; {of func Year}
  569.  
  570.  Function DMY_to_String(D,M,Y:word;format:byte): string;
  571.  {INTERNAL}
  572.  const
  573.      PadChar = '/';
  574.  var
  575.     DD,MM,YY : string[4];
  576.  begin
  577.      DD := Int_to_Str(D);
  578.      If D < 10 then
  579.         DD := '0'+DD;
  580.      MM := Int_to_Str(M);
  581.      If M < 10 then
  582.         MM := '0'+MM;
  583.      If Format in [MMDDYY,MMYY,DDMMYY] then
  584.      begin
  585.          If Y > 99 then
  586.             If Y > 2000 then
  587.                Y := Y - 2000
  588.             else
  589.                If Y > 1900 then
  590.                   Y := Y - 1900
  591.                else
  592.                   Y := Y Mod 100;
  593.      end
  594.      else
  595.      begin
  596.          If Y < 1900 then
  597.             If Y < LastYearNextCentuary then
  598.                Y := Y + 2000
  599.             else
  600.                Y := Y + 1900;
  601.      end;
  602.      YY := Int_to_Str(Y);
  603.      If Y < 10 then
  604.         YY := '0'+YY;
  605.      Case Format of
  606.      MMDDYY,
  607.      MMDDYYYY: DMY_to_String := MM+PadChar+DD+Padchar+YY;
  608.      MMYY,
  609.      MMYYYY  : DMY_to_String := MM+Padchar+YY;
  610.      DDMMYY,
  611.      DDMMYYYY: DMY_to_String := DD+PadChar+MM+Padchar+YY;
  612.      end; {case}
  613.  end; {of func DMY_to_String}
  614.  
  615.  Function Date_To_Julian(InDate:string;format:byte): dates;
  616.  {Does not check the date is valid. Passed a date string and
  617.   returns a julian date}
  618.  var
  619.     D,M,Y :  word;
  620.     Temp : dates;
  621.  begin
  622.      D := Day(Indate,format);
  623.      M := Month(Indate,format);
  624.      Y := Year(Indate,format);
  625.      If  (Y=1900)
  626.      and (M <= 2) then
  627.      begin
  628.          If M = 1 then
  629.             Temp := pred(D)
  630.          else
  631.             Temp := D+30;
  632.      end
  633.      else
  634.      begin
  635.          If M > 2 then
  636.             M := M - 3
  637.          else
  638.          begin
  639.              M := M + 9;
  640.              dec(Y);
  641.          end;
  642.          Y := Y - 1900;
  643.          Temp := (1461*longint(Y) div 4) +
  644.                  (153*M+2) div 5 +
  645.                  D + 58;
  646.      end;
  647.      Date_to_Julian := Temp;
  648.  end; {of func Date_To_Julian}
  649.  
  650.  Function Julian_to_Date(J:dates;format:byte):string;
  651.  {}
  652.  var
  653.     D,M,Y : word;
  654.     Remainder,Factored : longint;
  655.  begin
  656.      If J = 0 then
  657.      begin
  658.          Case Format of
  659.          DDMMYY,MMDDYY :   Julian_to_date := '  /  /  ';
  660.          DDMMYYYY,MMDDYYYY:Julian_to_date := '  /  /    ';
  661.          MMYYYY:           Julian_to_Date := '  /    ';
  662.          else              Julian_to_date := '  /  ';
  663.          end;
  664.          exit;
  665.      end;
  666.      If J <= 58 then
  667.      begin
  668.          Y := 1900;
  669.          If J <= 30 then
  670.          begin
  671.              M := 1;
  672.              D := succ(J);
  673.          end
  674.          else
  675.          begin
  676.              M := 2;
  677.              D := J - 30;
  678.          end;
  679.      end
  680.      else
  681.      begin
  682.          Factored := 4*LongInt(J) - 233;
  683.          Y := Factored div 1461;
  684.          Remainder := (Factored mod 1461 div 4 * 5) + 2;
  685.          M := Remainder div 153;
  686.          D := succ((Remainder mod 153) div 5);
  687.          Y := Y + 1900;
  688.          If M < 10 then
  689.             M := M + 3
  690.          else
  691.          begin
  692.              M := M - 9;
  693.              Inc(Y);
  694.          end;
  695.      end;
  696.      Julian_to_date := DMY_to_String(D,M,Y,format);
  697.  end; {of proc Julian_to_Date}
  698.  
  699.  Function Date_Within_Range(Min,Max,Test:dates):boolean;
  700.  {}
  701.  begin
  702.      Date_Within_Range := ((Test >= Min) and (Test <= Max));
  703.  end; {of func Date_Within_Range}
  704.  
  705.  Function Valid_Date(Indate:string;format:byte): boolean;
  706.  {}
  707.  var
  708.    D,M,Y : word;
  709.    OK : Boolean;
  710.  begin
  711.      OK := true;  {positive thinking!}
  712.      If format in [MMYY,MMYYYY] then
  713.         D := 1
  714.      else
  715.         D := Day(Indate,format);
  716.      M := Month(Indate,format);
  717.      Y := Year(Indate,format);
  718.      If (D < 1)
  719.      or (D > 31)
  720.      or (M < 1)
  721.      or (M > 12)
  722.      or ((Y > 99) and (Y < 1900))
  723.      or (Y > 2078)
  724.      then 
  725.         OK := False
  726.      else
  727.         Case M of
  728.         4,6,9,11:         OK :=   (D <= 30);
  729.         2:                OK :=   (D <= 28)
  730.                                or (
  731.                                         (D = 29) 
  732.                                     and (Y <> 1900) 
  733.                                     and (Y <> 0)
  734.                                     and (Y mod 4 = 0)
  735.                                   )
  736.         end; {case}
  737.      Valid_Date := OK;
  738.  end; {of func Valid_Date}
  739.  
  740.  Function Today_in_Julian: dates;
  741.  {}
  742.  var
  743.  Y,
  744.  M,
  745.  D,
  746.  DayOfWeek : word;
  747.  Year   : string;
  748.  Day    : string;
  749.  begin
  750.      GetDate(Y,M,D,DayofWeek);
  751.      Today_in_Julian := Date_to_Julian(DMY_to_String(D,M,Y,1),1);
  752.  end; {of func Today_in_Julian}
  753.  
  754.  Function Future_Date(InDate:string;format:byte;Days:word): string;
  755.  {}
  756.  var J : dates;
  757.  begin
  758.      Future_date := Julian_to_date(Date_to_Julian(InDate,Format)+Days,Format);
  759.  end; {of func Future_Date}
  760.  
  761.  Function Unformatted_date(InDate:string): string;
  762.  {strips all non numeric characters}
  763.  var I : Integer;
  764.  
  765.            Function digit(C:char): boolean;
  766.            {}
  767.            begin
  768.                Digit := C in ['0'..'9'];
  769.            end; {of func digit}
  770.  
  771.  begin
  772.      I := 1;
  773.      Repeat
  774.           If (digit(Indate[I]) = false) and (length(Indate) > 0) then
  775.              Delete(Indate,I,1)
  776.           else
  777.              I := succ(I);
  778.      Until (I > length(Indate)) or (Indate = '');
  779.      Unformatted_Date := Indate;
  780.  end; {of func Unformatted_date}
  781.  
  782.  
  783. begin
  784.     ClockX := 67;
  785.     ClockY := 1;
  786.     ClockF := white;
  787.     ClockB := black;
  788.     LPTport := 0;  {LPT1}
  789. end.
  790.